!
!
! Copyright (c) 2011, 2012
!   University of Houston System and Oak Ridge National Laboratory.
! 
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 
! o Redistributions of source code must retain the above copyright notice,
!   this list of conditions and the following disclaimer.
! 
! o Redistributions in binary form must reproduce the above copyright
!   notice, this list of conditions and the following disclaimer in the
!   documentation and/or other materials provided with the distribution.
! 
! o Neither the name of the University of Houston System, Oak Ridge
!   National Laboratory nor the names of its contributors may be used to
!   endorse or promote products derived from this software without specific
!   prior written permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
! HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
! TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!

program test_shmem_lock
  implicit none
  include 'shmem.fh'

  integer*8, save :: L
  integer  , save :: x

  integer         :: me, npes;
  integer         :: slp;
  integer         :: ret_val;
  integer         :: new_val;

  call start_pes(0)
  me   = my_pe()
  npes = num_pes()
  L = 0
  x = 0
  ret_val = -1

  if(npes .gt. 1) then

    slp = 1
    call shmem_barrier_all()

    call shmem_set_lock(L)

    call shmem_integer_get(new_val, x, 1, 0)
    new_val = new_val + 1

    call shmem_integer_put(x, new_val, 1, 0)  ! increment x on PE 0
    call shmem_quiet() 

    call shmem_clear_lock(L)

    call shmem_barrier_all()
 
    if(me .eq. 0) then
      if(x .eq. npes) then
        write(*,*) "Test for set, and clear lock: Passed"
      else
        write(*,*) "Test for set, and clear lock: Failed"
      end if
      x=0
    end if

    call shmem_barrier_all()

    ret_val = 1
    do while(ret_val .eq. 1)
      ret_val = shmem_test_lock(L)
    end do

    call shmem_integer_get(new_val, x, 1, 0)
    new_val = new_val + 1

    call shmem_integer_put(x, new_val, 1, 0)  ! increment x on PE 0 

    call shmem_quiet()

    call shmem_clear_lock(L)

    call shmem_barrier_all()

    if(me .eq. 0) then
      if(x .eq. npes) then
        write(*,*) "Test for test lock: Passed"
      else
        write(*,*) "Test for test lock: Failed"
      end if

    end if 

    call shmem_barrier_all()
  else
    write(*,*) "Number of PEs must be > 1 to test locks, test skipped"
  end if
end program test_shmem_lock
